home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / C / ASMLINK.C < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-24  |  2.9 KB  |  118 lines
  1. /* ASMLINK.C
  2.  ************************************************************************
  3.  *                                    *
  4.  *        PC Scheme/Geneva 4.00 Borland C code            *
  5.  *                                    *
  6.  * (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7.  * (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8.  *                                    *
  9.  *----------------------------------------------------------------------*
  10.  *                                    *
  11.  *        Assembly Interface to Scheme                *
  12.  *                                    *
  13.  *----------------------------------------------------------------------*
  14.  *                                    *
  15.  * Created by: L. Bartholdi & M. Vuilleumier    Date: 1992        *
  16.  * Revision history:                            *
  17.  * - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18.  *                                    *
  19.  *                    ``In nomine omnipotentii dei''    *
  20.  ************************************************************************/
  21.  
  22. #include    <stdarg.h>
  23. #include    <stdlib.h>
  24. #include    "scheme.h"
  25.  
  26. int    asm_link( int n_args, ...)
  27. {
  28.     int        i;
  29.     REGPTR        sarg;
  30.     LINKARG        carg[NUMARGS];
  31.     LINKVAL        cresult;
  32.     REGPTR        sresult;
  33.     int             stat;
  34.     va_list        vlist;
  35.  
  36.     va_start(vlist, n_args);        /* Convert every regptr */
  37.     for (i = 0; i < n_args; i++) {        /* Warning: this structure may be wrong */
  38.                         /* optimized (don't use i--)... (Thanks Borland) */
  39.         sarg = va_arg(vlist, REGPTR);
  40.         switch( gettype(sarg) )
  41.         {
  42.         case STRTYPE:
  43.             carg[n_args-1-i].type = STR;
  44.             carg[n_args-1-i].item.s = string_asciz(sarg);
  45.             break;
  46.         case BIGTYPE:
  47.         case FIXTYPE:
  48.             carg[n_args-1-i].type = INTEGER;
  49.             carg[n_args-1-i].item.i = int2long(sarg);
  50.             break;
  51.         case FLOTYPE:
  52.             carg[n_args-1-i].type = FLOAT;
  53.             carg[n_args-1-i].item.f = reg2c(sarg)->flonum.data;
  54.             break;
  55.         case CHARTYPE:
  56.             carg[n_args-1-i].type = CHARACTER;
  57.             carg[n_args-1-i].item.c = sarg->disp & 0xff;
  58.             break;
  59.         case SYMTYPE:
  60.         case LISTTYPE:
  61.             carg[n_args-1-i].type = BOOLEAN;
  62.             carg[n_args-1-i].item.b = (sarg->page == CORRPAGE(NIL_PAGE)) && 
  63.                           (sarg->disp == NIL_DISP);
  64.             break;
  65.         default:
  66.             return    -1;
  67.         }
  68.     }
  69.     sresult = sarg;                /* first arg was pushed first, so now it it the last arg... */
  70.     va_end(vlist);
  71.  
  72.     /* all arguments ready-- call the interface routine */
  73.     stat = link(&cresult, n_args-1, carg);
  74.  
  75.     /* release memory allocated for strings */
  76.     for (i = 0; i < n_args; i++) {
  77.         if (carg[i].type == STR)
  78.             rlsstr(carg[i].item.s);
  79.     }
  80.  
  81.     /*
  82.      * fetch result returned from low level return and make it a Scheme
  83.      * object
  84.      */
  85.     switch (stat) {
  86.     case NOVALUE:
  87.         break;
  88.  
  89.     case BOOLEAN:
  90.         bool2scm(sresult, cresult.b);
  91.         break;
  92.     case INTEGER:
  93.         long2int(sresult, cresult.i);
  94.         break;
  95.     case FLOAT:
  96.         alloc_flonum(sresult, cresult.f);
  97.         break;
  98.     case CHARACTER:
  99.         sresult->page = ADJPAGE(SPECCHAR);
  100.         sresult->disp = cresult.c;
  101.         break;
  102.     case STR:
  103.         alloc_string(sresult, cresult.s);
  104.         free(cresult.s);
  105.         break;
  106.     case STATSTR:
  107.         alloc_string(sresult, cresult.s);
  108.         break;
  109.     case SCHEME:
  110.         *sresult = cresult.r;
  111.         break;
  112.     default:
  113.         return    -1;
  114.     }
  115.  
  116.     return    0;
  117. }
  118.